
;;
;; context
;;

(defparameter *context* nil)

(defclass context ()
  (
   ;; types map
   (typemap :initform (make-hash-table) :reader typemap)

   ;; func map
   (funcmap :initform (make-hash-table) :reader funcmap)

   ;; identifies whether syntax analyzis requires context to
   ;; be revisited
   (sa-required :initform t :accessor sa-required)))


;;
;; type definitions
;;

(defclass p-type ()
  ((wrapper ; wrapper around this type
    :initform nil
    :accessor wrapper)))

(defclass p-type-anonymous (p-type)
  ())

(defclass p-type-alias (p-type)
  ((alias ; alias type this one points to
    :initform (error 'ctor-error :entity 'alias)
    :initarg :alias
    :reader alias)))

(defclass p-typed-id ()
  ((type-id
    :initform nil
    :initarg :type-id
    :reader type-id)
   (var-id
    :initform (error 'ctor-error :entity 'var-id)
    :initarg :var-id
    :reader var-id)))

(defclass p-type-struct (p-type)
  ((fields ; fields of the particular structure
    :initform (error 'ctor-error :entity 'fields)
    :initarg :fields
    :reader fields)))

;; represents extern types
(defclass p-type-extern (p-type)
  ((c-name ; name in C
    :initform nil :initarg :c-name :reader c-name)
   (c-header ; header file
    :initform nil :initarg :c-header :reader c-header)
   (invalid-value ; value that renders result as invalid one
    :initform nil :initarg :invalid-value :reader invalid-value)))

;;
;; toplev parse
;;

(defgeneric p-toplev (id args))


;;
;; toplev parse: type decl
;;

(defun init-types ())

(defun add-type-def (type-id type-spec)
  (if (gethash type-id (typemap *context*))
      (error 'duplicate-definition :entity type-id))
  (setf (gethash type-id (typemap *context*)) type-spec))

(defgeneric t-spec (id args))

(defmethod t-spec ((id (eql nil)) args)
  (if args (error 'syntax-error
		  :reason "invalid form"
		  :entity args
		  :where "anonymous type definition"))
  (make-instance 'p-type-anonymous))

(defmethod t-spec ((id (eql 'struct)) args)
  (make-instance
   'p-type-struct
   :fields (loop for field-desc in args collect
		(if (symbolp field-desc)
		    ;; {var} form
		    (make-instance 'p-typed-var :var field-desc)
		    ;; ({var} {type-id}) form
		    (destructuring-bind (var type-id) field-desc
		      (make-instance 'p-typed-var
				     :var var :type-id type-id))))))

(defmethod t-spec ((id (eql 'enum)) args)
  (error 'not-implemented :where "t-spec (id (eql 'enum))"))

(defmethod t-spec ((id (eql 'extern)) args)
  (let ((c-name nil) (c-header nil) (invalid-value nil))
    (dolist (extern-spec args)
      (destructuring-bind (key value) extern-spec
	(case key
	  ;; predefined fields in p-type-extern
	  (c-name (setf c-name value))
	  (c-header (setf c-header value))
	  (invalid-value (setf invalid-value value))
	  ;; error signal
	  (t (error 'syntax-error
		    :reason "unknown extern type spec"
		    :where args :entity key)))))
    (make-instance 'p-type-extern
		   :c-name c-name :c-header c-header
		   :invalid-value invalid-value)))

(defmethod p-toplev ((id (eql 'type)) args)
  (destructuring-bind (type-id &optional type-spec) args
    (add-type-def
     type-id
     (cond
       ;; parse list definition
       ((listp type-spec) (t-spec (car type-spec) (cdr type-spec)))
       ;; add alias directly
       ((symbolp type-spec) (make-instance 'p-type-alias :alias type-spec))
       (t (error 'syntax-error
		 :reason "unknown type spec form"
		 :entity type-spec))))))


;;
;; toplev parse: function declaration
;;

(defun init-funcs ())

(defclass p-func ()
  ((arg-list :initform (error 'ctor-error :entity 'arg-list)
	     :initarg :arg-list :reader arg-list)

   ;; function's body
   (body :initform (error 'ctor-error :entity 'body)
	 :initarg :body :reader body)

   ;; lifetime - or - when the function appears to happen
   ;; :compiletime or :runtime, :unknown at initialization point
   (lifetime :initform :unknown :accessor lifetime)

   ;; points to the next p-func instance
   (next :initform nil :accessor next)))

(defun add-func-def (func-name func-def)
  ;; check whether such a function exists
  (if (gethash func-name (funcmap *context*))
      (error 'duplicate-definition :entity func-name))
  ;; put new function definition
  (setf (gethash func-name (funcmap *context*)) func-def))

(defmethod p-toplev ((id (eql 'func)) args)
  (destructuring-bind (func-name arg-list &body body) args
    (add-func-def func-name (make-instance
			     'p-func :arg-list arg-list :body body))))


;;
;; parser entry point
;;

(defun parse (decl)
  (p-toplev (car decl) (cdr decl)))

(defun parse-forms (forms)
  (format t "parsing forms ~a~%" forms)
  (dolist (decl forms)
    (format t "~a > ~a~%" decl (parse decl))))


;;
;; semantics analyzer part
;;

(defun eval-expr (self-id func-spec expr)
  (if (atom expr)
      ;; atomic expressions handling (nothing here)
      nil
      ;; s-expression
      (let ((id (car expr)))
	;; don't care about the recursive calls
	(unless (eq self-id id)
	  (let ((inf-expr (gethash id (funcmap *context*))))
	    ;;(if (null expr) (error 'not-found :entity id :where expr))
	    (format t "func-spec = ~a~%" (list inf-expr func-spec)))))))

(defun s-analyze-func (func-id func-spec)
  "analyzes a particular function"
  (format t "func ~a : ~a~%" func-id func-spec)

  ;; evaluate body declaration
  (let ((body (body func-spec)))
    (dolist (expr body)
      (eval-expr func-id func-spec expr))))

(defun s-analyze-type (type-id type-spec)
  "analyzes a particular type"
  (format t "type ~a : ~a~%" type-id type-spec))

(defun s-analyze ()
  "performs semantic analyzis"

  (loop while (sa-required *context*) do
       (progn
	 ;; reset flag
	 (setf (sa-required *context*) nil)
	 ;; go over the functions list
	 (maphash (lambda (key value) (s-analyze-func key value))
		  (funcmap *context*))
	 ;; go over types
	 (maphash (lambda (key value) (s-analyze-type key value))
		  (typemap *context*)))))

;;
;; context initializer
;;

(defun create-context ()
  (setf *context* (make-instance 'context))
  (init-types)
  (init-funcs))

;;
;; compile-time support
;;


(defun emit (target &rest args)
  "emits certain declarations"
  (format t "emit ~a ~a~%" target args))


;;
;; tests
;;

(defparameter *test-forms-1*
  '((type number)
    (type uint (extern (c-name "unsigned int")))

    (func bar ()
     (+ 2 3))

    (func baz-f (arg1 size name)
     (args (arg1 int) (size uint))
     (printf "arg1 = %d" arg1))
    
    (type foo (struct (age int) life))))

(defparameter *test-forms-2*
  '((func ct-fn-1 ()
     (+ 2 3))

    (func printf (format-str arg)
     (traits extern))

    (func main ())))

(defun p-experiment-tests ()
  (format t "running tests~%")

  ;; create operational context
  (create-context)

  (parse-forms *test-forms-2*)

  ;; analyze semantics
  (s-analyze))


;;
;; individual tests
;;

(defparameter *individual-tests*
  '(
    (run-tests)

    (parse '(type animal (struct (age int) life)))

    (parse '(type file (extern
			(c-name "FILE *")
			(c-pointer 1)
			(c-header "stdio"))))
    
    (parse '(func fopen (file-name open-mode)
	     (args (file-name const-char-p) (open-mode const-char-p))
	     (return file (traits (invalid-value c-null)))
	     (traits extern (c-name "fopen") (c-header "stdio"))))

    (module "sample"
     (type element-size size)
     (type count size)

     (func fread (buffer element-size count file)
      (arg buffer void-p)
      (return size)
      (traits extern (c-name "fread") (c-header "stdio")))
     
     ) ;; sample module

    (chset "sample changeset"
     ;; helper function
     (func some-func (arg1 arg2)
      (do-smth arg1 arg2 1 2 3))

     ;; language query
     (query (call-to "fopen")
      ;; for all the fopen call
      (wrap (node)
	    (emit 'call 'some-func 1 2)
	    (emit node)))) ;; chset sample
    ))
